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-- file Pass3Xb.Mesa 

-- last modified by Satterthwaite, August 3, 1978 9:53 AM 

DIRECTORY 

ComData: FROM "comdata" 
USING [ 

ownSymbols. typeBOOLEAN, typeCHARACTER, typelNTEGER, typeSTRING, xref], 
ErrorDefs: FROM "errordefs" USING [error, errorn, errortree], 
LitDefs: FROM "litdefs" USING [StringLiteralValue], 
P3Defs: FROM "p3defs" 
USING [ 

Addr, Apply, Assignment, BumpCount, Bundling, CanonicalType, Case, 
DescOp, Discrimination, Dot, Fork, Id, Identif iedType, Join, 
MakeLongType, New, OrderedType, PopCtx, PushCtx, Range, RecordReference , 
Signal. Start, TargetType, TypeExp, TypeForTree, Unbundle, UpArrow], 
Pass3: FROM "pass3" USING [impl icitRecord, impl icitTree, impl icitType], 
SymDefs: FROM "symdefs" 
USING [ctxtype, setype, 

SEIndex, ISEIndex, CSEIndex, recordCSEIndex, CSENull, 
recordCSENull , codeCHARACTER, codelNTEGER, typeANY], 
SymTabDefs: FROM "symtabdefs" 

USING [NormalType, TypeForm, UnderType, XferMode], 
TableDefs: FROM "tabledefs" USING [TableBase, TableNoti rier], 
TreeDefs: FROM "treedefs" 
USING [treetype, 

Treelndex, TreeLink, TreeMap. empty, 

GetNode, listlength, mlpop, mlpush, pushtree, setinfo, testtree, 
updatel ist], 
TypePackDefs: FROM "typepackdefs" 

USING [SymbolTableBase, AssignableTypes , EquivalentTypes]; 

Pass3Xb: PROGRAM 
IMPORTS 

ErrorDefs, LitDefs, P3Defs, SymTabDefs, TreeDefs, TypePackDefs, 
dataPtr: ComData, passPtr: Pass3 
EXPORTS P3Defs = 
BEGIN 
OPEN SymTabDefs, TreeDefs, P3Defs; 

-- pervasive definitions from SymDefs 

SEIndex: TYPE « SymDefs .SEIndex; 
ISEIndex: TYPE = SymDefs . ISEIndex; 
CSEIndex: TYPE = SymDefs .CSEIndex; 
RecordSEIndex: TYPE = SymDefs . recordCSEIndex; 
typeANY: SymDefs .CSEIndex = SymDefs .typeANY; 

tb: TableDefs. TableBase; -- tree base address (local copy) 
seb: TableDefs .TableBase; -- se table base address (local copy) 
ctxb: TableDefs. TableBase; -~ context table base address (local copy) 

own: TypePackDefs. Symbol TableBase; 

ExpBNotify: PUBLIC TableDefs . TableNotifier = 

BEGIN ~- called by allocator whenever table area is repacked 
seb <r base[SymDefs. setype]; ctxb ^ base[SymDefs. ctxtype]; 
tb ♦- base[treetype]; RETURN 
END; 

-- intermediate result bookkeeping 

OperandDescriptor: TYPE = RECORD[ 

type: CSEIndex, -- type of operand 

const: BOOLEAN]; -- true iff a manifest constant 

RStackLimit: INTEGER » 32; 

rStack: ARRAY [0 .. RStackLimit] OF OperandDescriptor; 

rl: INTEGER; -- index into rStack 

OperandStackOverflow: SIGNAL « CODE; 

RPush: PUBLIC PROCEDURE [type: CSEIndex, const: BOOLEAN] « 
BEGIN 
IF rl >« RStackLimit THEN ERROR OperandStackOverflow; 
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rl ^ rl + 1; 

rStack[rI] <- OperanclDescriptor[type: type, const:const] ; 

RETURN 

END; 

RPop: PUBLIC PROCEDURE - 
BEGIN 

IF rl < THEN ERROR; 
rl <r rI-1; RETURN 
END; 

RType: PUBLIC PROCEDURE RETURNS [CSEIndex] - 
BEGIN 

RETURN [rStack[rI].type] 
END; 

RConst: PUBLIC PROCEDURE RETURNS [BOOLEAN] - 
BEGIN 

RETURN [rStackCrl]. const] 
END; 

Explnit: PUBLIC PROCEDURE « 
BEGIN 

passPtr. implicitType <- typeANY; passPtr . impl icitTree ^ empty; 
passPtr . imp! icitRecord <- SymDef s . recordCSENull ; 
own <r dataPtr.ownSymbols; -- make a parameter? 
rl 4- -1; RETURN 
END; 

-- tree manipulation utilities 

OperandType: PUBLIC PROCEDURE [t: TreeLink] RETURNS [CSEIndex] « 
BEGIN 
RETURN [WITH e:t SELECT FROM 

symbol => UnderType[(seb+e. index) . idtype] , 
literal »> 

WITH e.info SELECT FROM 

string => dataPtr. typeSTRING, 
ENDCASE »> dataPtr.typelNTEGER. 
subtree => (tb+e. index) . info, 
ENDCASE «> SymDef s.CSENull] 
END; 

-- type manipulation 

UnresolvedTypes: SIGNAL RETURNS [CSEIndex] = CODE; 

BalanceTypes: PROCEDURE [typel, type2: CSEIndex] RETURNS [type: CSEIndex] 
BEGIN 

nl, n2: CARDINAL; 
SELECT TRUE FROM 

(typel = type2), (type2 = typeANY) => type ♦- typel; 
(typel = typeANY) «> type <- type2; 
ENDCASE «> 
BEGIN 

nl <- Bundling[typel]; 
n2 ♦- Bundl ing[type2]; 
WHILE nl > n2 

DO typel ^ Unbundle[LOOPHOLE[typel]]; nl <- nl-1 ENDLOOP; 
WHILE n2 > nl 

DO type2 ^ Unbundle[L00PH0LE[type2]] ; n2 <- n2-l ENDLOOP; 
-- check bundling 
DO 

typel <- TargetType[typel]; 
type2 <- TargetType[type2]; 
SELECT TRUE FROM 

TypePackDefs. AssignableTypes[[own, typel], [own, type2]] «> 

BEGIN type <- typel; EXIT END; 
TypePackDefs .AssignableTypes[[own, type2], [own, typel]] "> 

BEGIN type <- type2; EXIT END; 
ENDCASE; 
IF nl « THEN GO TO Fail; 
nl <- nl-1 ; 
typel ^ Unbundle[LOOPHOLE[typel]]; 
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type2 ^ Unbuncne[L00PH0LE[type2]]; 
REPEAT 

Fail ■> type ♦- SIGNAL Unresol vedTypes; 
ENDLOOP; 
END; 
RETURN 
END; 

ForceType: PUBLIC PROCEDURE [t: TreeLink. type: CSEIndex] RETURNS [TreeLink] » 
BEGIN 

m1push[t]; 
WITH t SELECT FROM 
subtree «> 

SELECT (tb+index).name FROM 

constructx, vconstructx, unionx, rowconsx «> pushtree[cast. 1]; 
ENDCASE; 
ENDCASE ■> pushtree[cast. 1]; 
setinfo[type]; RETURN [nilpop[]] 
END; 

■- expressions 

Exp: PUBLIC PROCEDURE [exp: TreeLink, target: CSEIndex] RETURNS [val : TreeLink] 
BEGIN 

sei: ISEIndex; 
type: CSEIndex; 
node: Treelndex; 
const: BOOLEAN; 
IF exp = empty 

THEN BEGIN RPush[passPtr . imp! ici tType , FALSE]; RETURN [empty] END; 
WITH e:exp SELECT FROM 
symbol »> 
BEGIN 

sei <- e. index; BumpCount[sei]; 

IF dataPtr.xref THEN RecordReference[sei . mention]; 
type <- UnderType[(seb+sei) . idtype]; 

const <- (seb+sei ). constant AND XferMode[type] # procedure; 
RPush[type, const]; val <- exp; 
END; 
hash => 

WITH (seb+target) SELECT FROM 
enumerated => 

BEGIN PushCtx[valuectx]; 
val <- Id[e. index]; PopCtx[] 
END; 
ENDCASE => val ^ Id[e. index]; 
literal «> 
BEGIN 
WITH e.info SELECT FROM 

string => RPush[dataPtr . typeSTRING, FALSE]; 
ENDCASE ==> RPush[dataPtr.typeINTEGER. TRUE]; 
val <- exp; 
END; 
subtree -> 

BEGIN val ♦- exp; node <- e. index; 
SELECT (tb+node) .name FROM 
dot «> Dot[node]; 
uparrow «> UpArrow[node]; 
apply «> 

BEGIN Apply[node. target. FALSE]; CheckNonVoid[] END; 
uminus, abs => UnaryOp[node]; 
plus »> Plus[node]; 
minus => Minus[node]; 
times, div, mod => ArithOp[node]; 
relE, relN => RelOp[node, FALSE]; 
relL, relGE, relG, relLE «> RelOp[node, TRUE]; 
in, notin »> 
BEGIN OPEN (tb+node); 
sonl ^ GenericRhs[sonl, typeANY]; 
son2 *- Range[son2, rStack[rI]. type]; 

SetAttributes[node]; RPop[]; RPush[dataPtr. typeBOOLEAN, FALSE]; 
END; 
not «> Negation[node]; 
or, and => BoolOp[node] ; 
ifexp «> IfExp[node, target]; 
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caseexp ■> SelectExp[node, target, Case]; 

bindexp ■> SelectExp[node, target, Discrimination]; 

assignx ■> Assignment[node]; 

min, max »> MinMax[node, target]; 

addr «> Addr[node, target]; 

base, length, arraydesc «> DescOp[node, target]; 

mwconst => 

RPush[MakeLongType[dataPtr.typeINTEGER, target], TRUE]; 
clit «> RPush[dataPtr.typeCHARACTER, TRUE]; 
Hit -=> RPush[dataPtr.typeSTRING. FALSE]; 
signal, error, start, join »> 
BEGIN 

val ^ SELECT (tb+node) iname FROM 
start ■> Start[node], 
join «> Join[node], 
ENDCASE «> SignalCnode]; 
node <- GetNode[val]; 
CheckNonVoid[]; 
END; 
new, fork »> 
BEGIN 

val <- (IF (tb+node) .name ■ fork 
THEN Fork 

ELSE New)[node, target]; 
node <- GetNode[val ] ; 
END; 
lengthen »> 

BEGIN OPEN (tb+node); 
type: CSEIndex; 

sonl <- GenericRhs[sonl, target]; type <- rStack[rI]. type; 
IF type = dataPtr. typelNTEGER 
OR (seb+type) . typetag = pointer 
OR (seb+type) . typetag = arraydesc 
THEN rStack[rI]. type *- MakeLongType[type, target] 
ELSE 
BEGIN 

ErrorDef s .errortree[typeClash. sonl] ; 
rStack[rI].type ^ typeANY; 
END; 
END; 
loophole => 

BEGIN OPEN (tb+node); 
sonl ♦- Exp[sonl, typeANY]; 
IF son2 = empty 
THEN 
BEGIN 
IF target « typeANY 

THEN ErrorDefs.errortree[noTarget, [subtree[node]]]; 
rStack[rI] . type ♦- target; 
END 
ELSE 

BEGIN son2 ^ TypeExp[son2] ; 

rStack[rI].type ♦- UnderType[TypeForTree[son2]]; 
END; 
END; 
register *> 

BEGIN OPEN (tb+node); 

sonl <- Rhs[sonl. dataPtr . typelNTEGER] ; attrl *- FALSE; 
IF ~rStack[rI]. const THEN ErrorDef s . errortree[nonConstant, sonl]; 
RPop[]; RPush[typeANY, FALSE]; 
END; 
memory «> 

BEGIN OPEN (tb+node); 

sonl <- Rhs[sonl, dataPtr . typelNTEGER]; attrl <- FALSE; 
RPop[]: RPush[typeANY, FALSE]; 
END; 
size »> 

BEGIN OPEN (tb+node); 
sonl +- TypeExp[sonl] ; 
RPush[dataPtr. typelNTEGER. TRUE]; 
END; 
first, last ■> EndPoint[node]; 

item "> (tb+node) .son2 <- Exp[(tb+node) .son2, target]; 
ENDCASE «> 

BEGIN ErrorDef s. error [un implemented]; 
RPush[typeANY, FALSE]; 
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END; 
(tb+node) . info *- rStack[rI] . type; 
END; 
ENDCASE; 
RETURN 
END; 

CheckNonVoid: PROCEDURE - 
BEGIN 

IF rStack[rI].type » SymDef s.CSENull 
THEN 

BEGIN ErrorDef s.error[voidExpr]; 
rStack[rI]. type ^ typeANY; 
END; 
RETURN 
END; 

VoidExp: PUBLIC PROCEDURE [exp: TreeLink] RETURNS [val : TreeLink] ■ 
BEGIN 

val <- Exp[exp, typeANY]; RPop[3; RETURN 
END; 

-- literals 

TreeStringValue: PUBLIC PROCEDURE [t: TreeLink] RETURNS [STRING] « 
BEGIN 

WITH e:t SELECT FROM 
literal => 

WITH e.info SELECT FROM 

string «> RETURN [LitDefs .StringLiteralValue[ index]]; 
ENDCASE; 
ENDCASE; 
ERROR 
END; 

-- arithmetic expression manipulation 

EvalNumeric: PROCEDURE [t: TreeLink] RETURNS [val: TreeLink] » 
BEGIN 

val <- 6enericRhs[t. dataPtr . typelNTEGER]; 
SELECT NormalType[rStack[rI].type] FROM 

dataPtr. typelNTEGER => NULL; 

typeANY => rStack[rI]. type ^ dataPtr .typelNTEGER; 

ENDCASE => ErrorDefs.errortree[typeClash, val]; 
RETURN 
END; 

ArithOp: PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 

sonl <- EvalNumeric[sonl]; son2 ♦- EvalNumeric[son2] ; 
BalanceAttributes[node]; 

rStack[rI--l]. const ^ rStack[rI-l] .const AND rStack[rI] .const AND -attrl; 
RPop[]; RETURN 
END; 

ArithType: PROCEDURE [type: CSEIndex] RETURNS [CSEIndex] - 
BEGIN 

type <- NormalType[type]; 
RETURN [WITH (seb+type) SELECT FROM 

relative => NormalType[UnderType[oFf setType]] , 
ENDCASE «> type] 
END; 

Plus: PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
type: CSEIndex; 
Ir: BOOLEAN; 

sonl +- GenericRhs[sonl, typeANY]; 
type ♦- ArithType[rStack[rI]. type]; 
IF (seb+type). typetag « pointer OR type ■ dataPtr. typeCHARACTER 

THEN BEGIN Ir <- TRUE; son2 <- EvalNumeric[son2] END 

ELSE 
BEGIN 
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SELECT type FROM 

dataPtr.typelNTEGER. typeANY -> NULL; 
ENDCASE »> ErrorDefs.errortree[typeClash, sonl]; 
son2 ^ GenericRhs[son2, typeANY]; 
Ir ♦- FALSE; type *- ArithType[rStack[rI] . type]; 
IF (seb+type) .typetag « pointer OR type « dataPtr . typeCHARACTER 
THEN NULL 
ELSE 
BEGIN 
SELECT type FROM 

dataPtr.typelNTEGER »> NULL; 

typeANY -> rStack[rI] . type ♦- dataPtr.typelNTEGER; 
ENDCASE ■> ErrorDefs.errortree[typeC1ash. son2]; 
END; 
END; 
Ba1anceAttributes[node]; 

rStack[rI~l]. const ♦- rStack[rI-l] .const AND rStack[rI] .const AND -attrl; 
IF -Ir THEN rStack[rI-l] . type ♦- rStack[rI] . type; 
RPop[]; RETURN 
END; 

Minus: PROCEDURE [node: Treelndex] » 
BEGIN OPEN (tb+node); 
type, subType: CSEIndex; 
Ir: BOOLEAN; 

sonl <- GenericRhs[sonl. typeANY]; 

type <- Norma1Type[rStack[rI] . type]; subType <- ArithType[type]; Ir ♦- TRUE; 
IF (seb+subType) .typetag = pointer OR subType = dataPtr . typeCHARACTER 
THEN 
BEGIN 

son2 <- GenericRhs[son2, typeANY]; 
subType <- Norma1Type[rStack[rI]. type]; 
SELECT TRUE FROM 

subType = typeANY => NULL; 
TypePackDefs.Equiva1entTypes[[own, type], [own, subType]] *> 

Ir *- FALSE; 
subType = dataPtr.typelNTEGER ««> NULL; 
ENDCASE => ErrorDefs.errortree[typeClash, son2]; 
END 
ELSE 
BEGIN 
SELECT type FROM 

dataPtr.typelNTEGER, typeANY «> NULL; 
ENDCASE => ErrorDefs.errortree[typeClash, sonl]; 
son2 ♦- EvalNumeric[son2]; 
END; 
BalanceAt tributes [node]; 

rStack[rI-l]. const ♦- rStack[rI--l] .const AND rStack[rI] .const AND -attrl; 
IF ~lr 

THEN rStack[rI-l].type <- IF attrl 

THEN MakeLongType[dataPtr.typeINTEGER, rStack[rI] . type] 
ELSE dataPtr.typelNTEGER; 
RPop[]; RETURN 
END; 

UnaryOp: PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
1: CARDINAL = 1 ist1ength[sonl] ; 
IF 1 « 1 
THEN 
BEGIN 

sonl <r Eva1Nuineric[sonl] ; SetAttributes[node] ; 
IF attrl THEN rStack[rI] . const ^ FALSE; 
END 
ELSE 
BEGIN 
IF 1 > 1 

THEN ErrorDefs.errorn[1 istLong, 1-1] 
ELSE ErrorDef s.errorn[l istShort, 1+1]; 
sonl *- update] ist[sonl, VoidExp]; 
RPush[typeANY, FALSE]; 
END; 
RETURN 
END; 

RelOp: PROCEDURE [node: Treelndex, ordered: BOOLEAN] - 
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BEGIN OPEN (tb+node); 

type: CSEIndex; 

const: BOOLEAN; 

sonl ♦- GenericRhs[sonl, typeANY]; 

type ♦■ Norma1Type[rStack[rI].type]; 

sonZ <- GenericRhs[son2, type]; 

type ^ BalanceTypes[type, Norma1Type[rStack[rI], type] 

lUnresolvedTypes ■> 
BEGIN ErrorDefs.errortree[typeC1ash, sonZ]; RESUME [typeANY] END]; 
IF (ordered AND -'OrderedTypeCtype]) OR 
(-ordered AND ~Identif iedType[type]) 

THEN ErrorDef s .errortree[re1ationType, [subtree[node]]] ; 
IF sonl j^ empty THEN Bal anceAttributes[node] ELSE SetAttributes[node]; 
const ^ SELECT (seb+type) . typetag FROM 

basic, enumerated ■> rStack[rI-l]. const AND rStack[rI] .const, 

ENDCASE => FALSE; 
RPop[]; RPop[]; RPush[dataPtr . typeBOOLEAN, const]; 
RETURN 
END; 

Negation: PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
const: BOOLEAN; 

sonl <- Rhs[sonl, dataPtr .typeBOOLEAN]; 
const ^ rStack[rI]. const; 

RPop[]; RPush[dataPtr. typeBOOLEAN, const]; 
RETURN 
END; 

BoolOp: PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
const: BOOLEAN; 

sonl *- Rhs[sonl, dataPtr .typeBOOLEAN]; 
son2 <- Rhs[son2, dataPtr .typeBOOLEAN]; 
const <- rStack[rI-l]. const AND rStack[rI]. const; 
RPop[]; RPop[]; RPush[dataPtr .typeBOOLEAN, const]; 
RETURN 
END; 

BalancedTarget: PROCEDURE [target, type: CSEIndex] RETURNS [CSEIndex] =» 
BEGIN 
RETURN [IF target » typeANY 

OR (~TypePackDefs.Equiva1entTypes[[own, type], [own, target]] 
AND Norma1Type[type] « target) 
THEN TargetType[type] 
ELSE target] 
END; 

ResolveTypes: PROCEDURE [typel, type2, target: CSEIndex, t: TreeLink] 
RETURNS [type: CSEIndex] « 
BEGIN 

failed: BOOLEAN; 
IF target = typeANY 
THEN failed <- TRUE 
ELSE 
BEGIN 

ENABLE UnresolvedTypes «> BEGIN failed ^ TRUE; RESUME [typeANY] END; 
failed ^ FALSE; 

typel *- BalanceTypes[target, typel]; 
type? ♦- BalanceTypes[target, type2]; 
type <- BalanceTypes[typel, type2]; 
END; 
IF failed 

THEN BEGIN ErrorDef s . errortree[typeCl ash , t]; type <- typeANY END; 
RETURN 
END; 

IfExp: PROCEDURE [node: Treelndex, target: CSEIndex] « 
BEGIN OPEN (tb+node); 
type: CSEIndex; 
const: BOOLEAN; 

sonl <- Rhs[sonl, dataPtr . typeBOOLEAN]; 
const ♦- rStack[rI]. const; RPop[]; 

son2 <- BalancedRhs[son2, target]; const <- const AND rStack[rI]. const; 
type ^ rStack[rI]. type; RPop[]; 
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target <- BalancedTarg0t[target, type]; 

son3 ^ Ba1ancedRhs[son3, target]; const ^ const AND rStack[rI]. const; 
type ^ BalanceTypes[type, rStack[rI] . type 
lUnresolvedTypes »> 
RESUME [Reso1veTypes[type, rStack[rI] . type, target, sonS]]]; 
RPop[]; RPush[type, const]; RETURN 
END; 

SelectExp: PROCEDURE [node: Treelndex, target: CSEIndex, driver: PROCEDURE [Treelndex, TreeMap]] 
BEGIN 

type: CSEIndex; 
started: BOOLEAN; 

Selection: TreeMap » 
BEGIN 

subType: CSEIndex; 
V <- Ba1ancedRhs[t, target]; 
subType *- BalanceTypes[type, rStack[rI]. type 
lUnresolvedTypes «> 
RESUME [ResolveTypes[type, rStack[rI] . type, target, v]]]; 
IF subType # typeANY THEN type ^ subType; 
IF -started THEN target ♦- Ba1ancedTarget[target, type]; 
RPop[]; started <- TRUE; RETURN 
END; 

type ^ typeANY; started <- FALSE; 
driver[node. Selection]; 
RPush[type. FALSE]; RETURN 
END; 



MinMax: PROCEDURE [node: Treelndex, target: CSEIndex] « 
BEGIN OPEN (tb+node); 
const, started: BOOLEAN; 
type: CSEIndex; 

SubMinMax: TreeMap - 
BEGIN 

subType: CSEIndex; 
V ♦- Ba1ancedRhs[t , target]; 
const *- const AND rStack[rI] .const ; 
subType ^ CanonicalType[rStack[rI]. type]; 
subType <- BalanceTypes[subType, type 
lUnresolvedTypes «> 
RESUME[Reso1veTypes[subType, type, target, v]]]; 
IF type # subType AND subType # typeANY 
THEN 
BEGIN 
IF ~OrderedType[subType] 

THEN ErrorDef s .errortree[relationType, [subtree[node]]]; 
type *- subType; 

IF -started THEN target <- BalancedTarget[target , type]; 
END; 
RPop[]; started <- TRUE; RETURN 
END; 

const ^ TRUE; started <- FALSE; type ^ typeANY; 
sonl ♦- update! ist[sonl , SubMinMax]; 
SELECT (seb+type) .typetag FROM 

real => attrl ^ attr2 ♦- TRUE; 

long «> BEGIN attrl ^ TRUE; attr2 ^ FALSE END; 

ENDCASE => attrl <- attr2 <- FALSE; 
RPush[type, const AND -attrl]; RETURN 
END; 



EndPoint: PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
type: CSEIndex; 
sonl *r TypeExp[sonl]; 
type ♦- UnderType[Typ0ForTree[sonl]]; 
BEGIN 

WITH (seb+type) SELECT FROM 
basic »> 
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SELECT code FROM 

SymDefs.codelNTEGER, SymDef s.codeCHARACTER ■> NULL; 
ENDCASE «> GO TO fail; 
enumerated «> NULL; 
relative »> 

IF TypeForm[offsetType] /^ subrange THEN GO TO fail; 
subrange °> NULL; 
long ■> 

IF UnderType[rangetype] # dataPtr . typelNTEGER THEN GO TO fail; 
ENDCASE «> GO TO fail; 
EXITS 

fail ■> ErrorDefs.errortree[typeClash, sonl]; 
END; 
RPush[type. TRUE]; RETURN 
END; 

Rhs: PUBLIC PROCEDURE [exp: TreeLink, IhsType: CSEIndex] RETURNS [val : TreeLink] ■ 
BEGIN 

rhsType: CSEIndex; 
val ^ Exp[exp, IhsType]; 
rhsType ^ rStack[rI] . type; 
SELECT TRUE FROM 

(IhsType » rhsType), (IhsType « typeANY) => NULL; 
(rhsType « typeANY) «> rStack[rI] . type ♦- IhsType; 
ENDCASE -> 

BEGIN -- immediate matching is inconclusive 

UNTIL TypePackDef s .AssignableTypes[[own, IhsType], [own, rhsType]] 
DO 
WITH (seb+rhsType) SELECT FROM 

subrange => rhsType <- UnderType[rangetype]; 
record «> 
BEGIN 

IF Bundling[rhsType] = THEN GO TO nomatch; 
rhsType <- Unbundle[LOOPHOLE[rhsType , RecordSEIndex]]; 
val ♦- ForceType[val , rhsType]; 
END; 
ENDCASE «> 
BEGIN 

SELECT (seb+lhsType).typetag FROM 
long «> 
BEGIN 
IF -TypePackDefs.EquivalentTypesC 

[own, NormalType[lhsType]] , [own, rhsType]] 
THEN GO TO nomatch; 
val ♦- Lengthen[val , IhsType]; 
END; 
real => 
BEGIN 
IF NormalType[rhsType] ^ dataPtr . typelNTEGER 

THEN GO TO nomatch; 
val *- Float[val. rhsType, IhsType]; 
END; 
ENDCASE => GO TO nomatch; 
rhsType ♦- IhsType; 
END 
REPEAT 

nomatch => 

BEGIN -- no coercion is possible 
ErrorDefs .errortree[typeClash, 

IF exp = empty THEN passPtr . impl icitTree ELSE val]; 
rhsType <- IhsType; 
END; 
ENDLOOP; 
rStack[rI]. type ♦- rhsType; 
END; 
RETURN 
END; 

GenericRhs; PROCEDURE [exp: TreeLink, target: CSEIndex] RETURNS [val: TreeLink] » 
BEGIN 

type: CSEIndex; 

val <- Exp[exp. target]; type ♦- rStack[rI]. type; 
-- put value in canonical form 
DO 
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WITH (seb+type) SELECT FROM 

subrange ■> type ^ UnderType[rangetype]; 
record ■> 
BEGIN 

IF Bund1ing[type] = THEN EXIT; 
type ^ Unbundle[LOOPHOLE[type, RecordSEIndex]] ; 
val ♦- ForceType[val , type]; 
END; 
ENDCASE «> EXIT; 
rStack[rI].type ^ type; 
ENDLOOP; 
RETURN 
END; 

BalancedRhs: PROCEDURE [exp: TreeLink, target: CSEIndex] RETURNS [val: TreeLink] 
BEGIN 

type: CSEIndex; 
val <- Exp[exp, target]; 
SELECT (seb+target).typetag FROM 
long, real «> 
BEGIN 

type <- CanonicalType[rStack[rI].type]; 

IF type if typeANY AND (seb+target) . typetag # (seb+type) . typetag 
AND TypePackDef s.E qui val en t Types [ 

[own, NormalType[target]] , [own, type]] 
THEN 
BEGIN 
SELECT (seb+target) .typetag FROM 

long => val ♦- Lengthen[val , target]; 
real => val ♦- Float[val. type, target]; 
ENDCASE; 
rStack[rI].type *- target; rStack[rI]. const <- FALSE; 
END; 
END; 
ENDCASE; 
RETURN 
END; 

SetAttributes: PROCEDURE [node: Treelndex] « 
BEGIN 
SELECT (seb+rStack[rI]. type). typetag FROM 

long => BEGIN ( tb+node) . attrl <- TRUE; ( tb+node) . attrZ ^ FALSE END; 

real => (tb+node) . attrl <- (tb+node) . attr2 <- TRUE; 

ENDCASE => (tb+node). attrl <- (tb+node) .attr2 *- FALSE; 
RETURN 
END; 

BalanceAttributes: PROCEDURE [node: Treelndex] « 
BEGIN 

IType, rType: CSEIndex; 

IType ^ rStack[rI-l] . type; rType <- rStack[rI]. type; 
SELECT (seb+lType). typetag FROM 
long «> 
BEGIN 

(tb+node). attrl ^ TRUE; 
SELECT (seb+rType) .typetag FROM 
long => (tb+node) .attr2 *- FALSE; 
real => 
BEGIN 

rStack[rI-l] . type <- rType; 

(tb^-node) .sonl ^ Float[(tb+node) .sonl. IType, rType]; 
rStack[rI-l]. const <- FALSE; ( tb+node) . attr2 ^ TRUE; 
END; 
ENDCASE »> 
BEGIN 

rStack[rI] . type ♦- rType ^ MakeLongType[rType, IType]; 
(tb+node) .son2 ♦- Lengthen[( tb+node) . son2 , rType]; 
rStack[rI]. const ^ FALSE; (tb+node) . attr2 ♦- FALSE; 
END; 
END; 
real ■> 
BEGIN 

(tb+node) .attrl *- (tb+node) .attr2 ♦- TRUE; 
SELECT (sebfrType) .typetag FROM 
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real «> NULL; 
ENDCASE -> 

BEGIN 

rStack[rI].type ^ IType; 

(tb+node) .son2 <- F1oat[(tb«-nocle) . son2, rType, IType]; 

rStack[rI]. const <- FALSE; 

END; 
END; 
ENDCASE -> 

SELECT (seb+rType) .typetag FROM 
long "> 

BEGIN 

rStack[rI-l].type <- IType ^ MakeLongType[lType, rType]; 

(tb+node) .sonl ♦- Lengthen[(tb+node) . sonl, IType]; 

rStack[rI-l]. const <- FALSE; 

(tb+node). attn <- TRUE; (tb+node) .attr2 ♦- FALSE; 

END; 
real ■> 

BEGIN 

rStack[rI-l]. type <- rType; 

(tb+node) .sonl ♦- F1oat[(tb+node) .sonl, IType, rType]; 

rStack[rI-l]. const <- FALSE; 

(tb+node) .attn <r (tb+node) .attr2 <- TRUE; 

END; 
ENDCASE «> (tb+node). attn ^ (tb+node) .attr2 ♦- FALSE; 
RETURN 
END; 

Lengthen: PROCEDURE [t: TreeLink, target: CSEIndex] RETURNS [v: TreeLink] « 
BEGIN 
IF testtree[t, arraydesc] 

THEN V <- LengthenOesc[t, target] 
ELSE 
BEGIN 

m1push[t]; pushtree[lengthen , 1]; setinfo[target]; v ♦■ nilpop[]; 
END; 
RETURN 
END; 

LengthenDesc: PROCEDURE [t: TreeLink, target: CSEIndex] RETURNS [TreeLink] = 
BEGIN 

node: Treelndex = GetNode[t]; 
subNode: Treelndex = GetNode[(tb+node) . sonl]; 
(tb+subNode).sonl <- Lengthen[(tb+subNode) . sonl, 

MakeLongType[OperandType[(tb+subNode) .sonl], typeANY]]; 
(tb+node) . info *- MakeLongType[( tb+node) . info, target]; 
(tb+node). attrl <- TRUE; 
RETURN [t] 
END; 

Float: PROCEDURE [t: TreeLink, type, target: CSEIndex] RETURNS [TreeLink] « 
BEGIN 
IF NormalType[type] ff dataPtr. typelNTEGER 

THEN ErrorDefs.errortree[typeClash, t]; 
IF (seb+type) . typetag » long 

THEN mlpush[t] 

ELSE mlpush[Lengthen[t, MakeLongType[type , typeANY]]]; 
pushtree[f loat , 1]; setinf o[target]; 
RETURN [mlpop[]] 
END; 

END. 



